home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istp2 / ISTP2.f
Encoding:
Text File  |  1989-03-04  |  12.3 KB  |  397 lines
  1. * $pp$PARLEN=48
  2. C---------------------------------------------------------
  3. C    TOOLPACK/1    Release: 3.1
  4. C---------------------------------------------------------
  5. C
  6. C       I S T P 2   -   P R O G R A M   P A R A M E T E R S
  7. C       ---------       -------------   -------------------
  8. C
  9. C       (Monolithic Version)
  10. C
  11. C       This program processes a source file (at the token stream level)
  12. C       looking for $pp$ source-embedded directives.
  13. C
  14. C       A $pp$ SED defines a program-wide parameter.  ISTPP then looks
  15. C       through the rest of the program for PARAMETER statements which
  16. C       mention this name, and ensures that they all have the correct
  17. C       value.
  18. C
  19. C       There is also a facility for including a "library" file which
  20. C       contains SED's only (not a token stream).
  21. C
  22.  
  23.       PROGRAM ISTP2
  24.  
  25.       INTEGER MINUS,EOS,MAXPTH,READ,ERR,EOF,NO,STDERR,OK,WRITE,STDOUT
  26.       PARAMETER (MINUS=45,EOS=129,MAXPTH=81,READ=0,ERR=-1,EOF=-100,
  27.      +          NO=-3,STDERR=2,OK=-2,WRITE=1,STDOUT=1)
  28.  
  29.       INTEGER SRCPTH(MAXPTH),OUTPTH(MAXPTH),LIBPTH(MAXPTH),IODSRC,
  30.      +        IODOUT,IODLIB,TKIDES,TKODES,NOLIB(2)
  31.       LOGICAL ASKUSR
  32.  
  33.       INTEGER GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI,EQUAL
  34.       EXTERNAL GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI,EQUAL,ZINIT,ZQUIT,ERROR,
  35.      +         ZMESS
  36.  
  37.       DATA NOLIB/MINUS,EOS/
  38.  
  39.       CALL ZINIT
  40.  
  41.       IF (GETARG(1,SRCPTH,MAXPTH).EQ.EOF) CALL PPARGS(1,SRCPTH)
  42.       IODSRC = OPEN(SRCPTH,READ)
  43.       IF (IODSRC.EQ.ERR) CALL ERROR('Can''t open source file')
  44.       IF (GETARG(2,OUTPTH,MAXPTH).EQ.EOF) CALL PPARGS(2,OUTPTH)
  45.       IODOUT = CREATE(OUTPTH,WRITE)
  46.       IF (IODOUT.EQ.ERR) CALL ERROR('Can''t create output file')
  47.       ASKUSR = GETARG(3,LIBPTH,MAXPTH) .EQ. EOF
  48.       IF (ASKUSR) THEN
  49.           CALL ZMESS('Input library filenames, end with bla'//'nk line',
  50.      +               STDOUT)
  51.           CALL PPARGS(3,LIBPTH)
  52.       END IF
  53.  
  54.       IF (EQUAL(LIBPTH,NOLIB).EQ.NO .AND. LIBPTH(1).NE.EOS) THEN
  55.           IODLIB = OPEN(LIBPTH,READ)
  56.           IF (IODLIB.EQ.ERR) CALL ERROR('Can''t open library input')
  57.  
  58.       ELSE
  59.           IODLIB = -1
  60.       END IF
  61.  
  62.       TKIDES = ZTKGTI(0,IODSRC,ERR)
  63.       TKODES = ZTKPTI(0,IODOUT,ZTKGTI(2,0,0))
  64.  
  65.       CALL PPMAIN(TKIDES,TKODES,IODLIB,ASKUSR)
  66.  
  67.       CALL ZMESS('[ISTP2 Normal Termination]',STDERR)
  68.       CALL ZQUIT(OK)
  69.  
  70.       END
  71. C ----------------------------------------------------------------------
  72. C
  73. C       P P A R G S   -   Input ISTPP command arguments from user
  74. C
  75.  
  76.       SUBROUTINE PPARGS(N,PATH)
  77.  
  78.       INTEGER MAXPTH
  79.       PARAMETER (MAXPTH=81)
  80.  
  81.       INTEGER N,PATH(MAXPTH)
  82.  
  83.       INTEGER BIGI,LETP,LETU,LETT,BLANK,LETO,LETE,LETN,LETS,LETR,LETA,
  84.      +        COLON,EOS,LETC,LETF,LETI,LETL,BIGO,LETB,STDIN,LETY
  85.       PARAMETER (BIGI=73,LETN=110,LETP=112,LETU=117,LETT=116,BLANK=32,
  86.      +          LETO=111,LETE=101,LETS=115,LETR=114,LETA=97,COLON=58,
  87.      +          EOS=129,LETC=99,LETF=102,LETI=105,LETL=108,BIGO=79,
  88.      +          LETB=98,STDIN=0,LETY=121)
  89.  
  90.       INTEGER I,PROMPT(21,3)
  91.  
  92.       SAVE PROMPT
  93.  
  94.       INTEGER ZGTCMD
  95.       EXTERNAL ZGTCMD,ZPRMPT
  96.  
  97. C "Input source file: "
  98. C "Output file: "
  99. C "Input library file: "
  100.  
  101.       DATA (PROMPT(I,1),I=1,20)/BIGI,LETN,LETP,LETU,LETT,BLANK,LETS,
  102.      +     LETO,LETU,LETR,LETC,LETE,BLANK,LETF,LETI,LETL,LETE,COLON,
  103.      +     BLANK,EOS/
  104.       DATA (PROMPT(I,2),I=1,14)/BIGO,LETU,LETT,LETP,LETU,LETT,BLANK,
  105.      +     LETF,LETI,LETL,LETE,COLON,BLANK,EOS/
  106.       DATA (PROMPT(I,3),I=1,21)/BIGI,LETN,LETP,LETU,LETT,BLANK,LETL,
  107.      +     LETI,LETB,LETR,LETA,LETR,LETY,BLANK,LETF,LETI,LETL,LETE,
  108.      +     COLON,BLANK,EOS/
  109.  
  110.       CALL ZPRMPT(PROMPT(1,N))
  111.       I = ZGTCMD(PATH,STDIN)
  112.  
  113.       END
  114. C ----------------------------------------------------------------------
  115. C
  116. C       P P M A I N   -   ISTPP Main Processing
  117. C
  118.  
  119.       SUBROUTINE PPMAIN(TKIDES,TKODES,IODLIB,ASKUSR)
  120.       INTEGER TKIDES,TKODES,IODLIB
  121.       LOGICAL ASKUSR
  122.  
  123.       INTEGER MAXTLN,MAXBUF,PERCNT,LETI,LETN,LETC,LETL,LETU,LETD,LETE,
  124.      +        BLANK,PLUS,LESS,QMARK,GREATR,DOLLAR,EOS,AND,DIG1,ERR,STAR,
  125.      +        YES,LETP,OK,STDERR,BIGI,READ,MAXPRM,MAXPTH,EOF,TNAME,
  126.      +        TCOMMA,TRPARN,TEQUAL,TCMMNT,TPARAM,TZEOF,TZEOS
  127.       PARAMETER (MAXTLN=1322,MAXBUF=134,PERCNT=37,LETI=105,LETN=110,
  128.      +          LETC=99,LETL=108,LETU=117,LETD=100,LETE=101,BLANK=32,
  129.      +          PLUS=43,QMARK=63,GREATR=62,DOLLAR=36,EOS=129,AND=38,
  130.      +          DIG1=49,ERR=-1,STAR=42,YES=-2,LETP=112,OK=-2,STDERR=2,
  131.      +          BIGI=73,READ=0,MAXPRM=10,MAXPTH=81,EOF=-100,TNAME=76,
  132.      +          TCOMMA=48,TRPARN=52,TEQUAL=49,TPARAM=28,TZEOF=1,
  133.      +          TZEOS=79,LESS=60,TCMMNT=80)
  134.  
  135.       INTEGER PARLEN
  136.       PARAMETER (PARLEN=48)
  137.  
  138.       INTEGER MAXPAR,MAXINC
  139.       PARAMETER (MAXPAR=500,MAXINC=3)
  140.  
  141.       INTEGER NPARMS,TOKTYP,TOKLEN,TOKTXT(MAXTLN),STATUS,BIND,ID(3),
  142.      +        BODY(MAXBUF),LHS(MAXBUF),RHS(MAXBUF),INCDEP,
  143.      +        RESULT(MAXBUF),IODINC(MAXINC),PATTRN(16),REPLCE(3),PARNUM
  144.       LOGICAL INPARA
  145.       CHARACTER*(PARLEN) PTABLE(2,MAXPAR)
  146.  
  147.       LOGICAL LOOKUP
  148.  
  149.       INTEGER ZSEDID,ZSPLIT,LENGTH,ZGTCMD,ZPREPL,ZSETR,ZSETP,OPEN,GETARG
  150.       EXTERNAL ZSEDID,ZSPLIT,LENGTH,ZGTCMD,ZPREPL,ZSETR,ZSETP,OPEN,
  151.      +         GETARG,ZSCAN,ZUSCAN,ERROR,ZMESS,PUTLIN,ZCHOUT,CANT,ZPTMES
  152.  
  153. C PATTRN: "%include +<?+>$"
  154. C REPLCE: "&1"
  155.  
  156.       DATA PATTRN/PERCNT,LETI,LETN,LETC,LETL,LETU,LETD,LETE,BLANK,PLUS,
  157.      +     LESS,QMARK,PLUS,GREATR,DOLLAR,EOS/,REPLCE/AND,DIG1,EOS/
  158.  
  159. C
  160. C Initialise
  161. C
  162.       NPARMS = 0
  163.       INPARA = .FALSE.
  164.       ID(1) = EOS
  165.       ID(2) = 0
  166.       INCDEP = 1
  167.       IODINC(1) = IODLIB
  168.       IF (ZSETP(PATTRN,.TRUE.).EQ.ERR) CALL ERROR('ZSETP failed')
  169.       IF (ZSETR(REPLCE).EQ.ERR) CALL ERROR('ZSETR failed')
  170.       PARNUM = 6
  171. C
  172. C Process library file if necessary
  173. C
  174.       IF (IODLIB.GE.0) THEN
  175.   100     TOKLEN = ZGTCMD(TOKTXT,IODINC(INCDEP))
  176.           IF (TOKLEN.EQ.ERR) CALL ERROR('PPMAIN: I/O ERROR')
  177.           IF (TOKLEN.GE.0 .AND. TOKTXT(1).EQ.STAR) THEN
  178.               STATUS = ZSEDID(TOKTXT,BIND,ID,BODY)
  179.               IF (STATUS.EQ.YES .AND. ID(1).EQ.LETP .AND.
  180.      +            ID(2).EQ.LETP) THEN
  181.                   IF (ZSPLIT(BODY,LHS,RHS).NE.OK) THEN
  182.                       CALL ZCHOUT('Erroneous ISTPP directive:',stderr)
  183.                       CALL PUTLIN(BODY,stderr)
  184.                       CALL ZMESS(' - ignored',stderr)
  185.  
  186.                   ELSE IF (NPARMS.EQ.MAXPAR) THEN
  187.                       CALL ERROR('Too many parameters')
  188.  
  189.                   ELSE
  190.                       CALL ENTER(LHS,PTABLE,NPARMS,MAXPAR,RHS)
  191.                   END IF
  192.  
  193.               END IF
  194.  
  195.           ELSE IF (TOKLEN.GE.0 .AND. TOKTXT(1).EQ.LETI .OR.
  196.      +             TOKTXT(1).EQ.BIGI) THEN
  197.               IF (ZPREPL(TOKTXT,BODY,.FALSE.).EQ.ERR) THEN
  198.                   CALL ZCHOUT('Invalid INCLUDE statement: ',STDERR)
  199.                   CALL ZPTMES(TOKTXT,STDERR)
  200.  
  201.               ELSE IF (INCDEP.EQ.MAXINC) THEN
  202.                   CALL ZCHOUT('Error in: ',STDERR)
  203.                   CALL ZPTMES(TOKTXT,STDERR)
  204.                   CALL ERROR('INCLUDE files too deeply nested')
  205.  
  206.               ELSE
  207.                   INCDEP = INCDEP + 1
  208.                   IODINC(INCDEP) = OPEN(BODY,READ)
  209.                   IF (IODINC(INCDEP).EQ.ERR) THEN
  210.                       CALL CANT(BODY)
  211.                       CALL ERROR('ISTPP aborted')
  212.                   END IF
  213.  
  214.               END IF
  215.  
  216.           END IF
  217.  
  218.           IF (TOKLEN.NE.eof) GO TO 100
  219. C End of file - close it and decrement include nesting level
  220.           CALL CLOSE(IODINC(INCDEP))
  221.           INCDEP = INCDEP - 1
  222. C Keep going until end of top level library file
  223.           IF (INCDEP.GT.0) GO TO 100
  224.           PARNUM = PARNUM + 1
  225. C End of library file - see if we should do some more
  226.           IF (PARNUM.LE.MAXPRM) THEN
  227.               IF (ASKUSR) THEN
  228.                   CALL PPARGS(3,BODY)
  229.  
  230.               ELSE IF (GETARG(PARNUM,BODY,MAXPTH).EQ.EOF) THEN
  231.                   BODY(1) = EOS
  232.               END IF
  233.  
  234.               IF (BODY(1).NE.EOS) THEN
  235.                   INCDEP = 1
  236.                   IODINC(INCDEP) = OPEN(BODY,READ)
  237.                   IF (IODINC(INCDEP).NE.ERR) GO TO 100
  238.                   CALL CANT(BODY)
  239.                   CALL ERROR('ISTPP aborted')
  240.               END IF
  241.  
  242.           END IF
  243.  
  244.       END IF
  245. C
  246. C Process input
  247. C
  248.   200 CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  249.       IF (STATUS.EQ.ERR .OR. STATUS.EQ.
  250.      +    EOF) CALL ERROR('ZGETTK call failed')
  251.       IF (TOKTYP.EQ.TCMMNT .AND. TOKTXT(1).EQ.STAR) THEN
  252.           STATUS = ZSEDID(TOKTXT,BIND,ID,BODY)
  253.           IF (STATUS.EQ.YES .AND. ID(1).EQ.LETP .AND.
  254.      +        ID(2).EQ.LETP) THEN
  255.               IF (ZSPLIT(BODY,LHS,RHS).NE.OK) THEN
  256.                   CALL ZCHOUT('Erroneous ISTPP directive:',STDERR)
  257.                   CALL PUTLIN(BODY,STDERR)
  258.                   CALL ZMESS(' - ignored',STDERR)
  259.  
  260.               ELSE IF (NPARMS.EQ.MAXPAR) THEN
  261.                   CALL ERROR('Too many parameters')
  262.  
  263.               ELSE
  264.                   CALL ENTER(LHS,PTABLE,NPARMS,MAXPAR,RHS)
  265.               END IF
  266.  
  267.           END IF
  268.  
  269.       ELSE IF (TOKTYP.EQ.TPARAM) THEN
  270.           INPARA = .TRUE.
  271.  
  272.       ELSE IF (INPARA) THEN
  273.           IF (TOKTYP.EQ.TZEOS) THEN
  274.               INPARA = .FALSE.
  275.  
  276.           ELSE IF (TOKTYP.EQ.TNAME .AND. NPARMS.GT.0) THEN
  277.               IF (LOOKUP(TOKTXT,PTABLE,NPARMS,RESULT)) THEN
  278.                   CALL ZUSCAN(TOKTYP,TOKLEN,TOKTXT,TKODES)
  279.                   CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  280.                   IF (TOKTYP.EQ.TEQUAL) THEN
  281.                       CALL ZUSCAN(TOKTYP,TOKLEN,TOKTXT,TKODES)
  282.                       CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  283.                       CALL ZUSCAN(TNAME,LENGTH(RESULT),RESULT,TKODES)
  284.   300                 CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  285.                       IF (TOKTYP.EQ.TZEOS) CALL ERROR
  286.      +                    ('Invalid PARAMETER statement')
  287.                       IF (TOKTYP.NE.TCOMMA .AND.
  288.      +                    TOKTYP.NE.TRPARN) GO TO 300
  289.                   END IF
  290.  
  291.               END IF
  292.  
  293.           END IF
  294.  
  295.       END IF
  296.  
  297.       CALL ZUSCAN(TOKTYP,TOKLEN,TOKTXT,TKODES)
  298.       IF (TOKTYP.NE.TZEOF) GO TO 200
  299.  
  300.       END
  301. C ----------------------------------------------------------------------
  302. C
  303. C       E N T E R   -   Enter a parameter definition into the table
  304. C
  305.  
  306.       SUBROUTINE ENTER(IPNAME,PTABLE,NPARMS,MAXPAR,IPDEFN)
  307.  
  308.       INTEGER STDERR
  309.       PARAMETER (STDERR=2)
  310.  
  311.       INTEGER PARLEN
  312.       PARAMETER (PARLEN=48)
  313.  
  314.       INTEGER IPNAME(*),NPARMS,MAXPAR,IPDEFN(*)
  315.       CHARACTER*(PARLEN) PTABLE(2,MAXPAR)
  316.  
  317.       INTEGER NAMLEN,I
  318.       CHARACTER*(PARLEN) PNAME,PDEFN
  319.  
  320.       INTEGER LENGTH
  321.       EXTERNAL LENGTH,ZCHOUT,PUTLIN,ZMESS,ZTOCAP,ZITOF
  322.  
  323.       NAMLEN = LENGTH(IPNAME)
  324.       IF (NPARMS.EQ.MAXPAR) THEN
  325.           CALL ERROR('Too many parameters')
  326.  
  327.       ELSE IF (NAMLEN.GE.PARLEN) THEN
  328.           CALL ZCHOUT('Parameter name "',STDERR)
  329.           CALL PUTLIN(IPNAME,STDERR)
  330.           CALL ZMESS('" is too long',STDERR)
  331.           CALL ERROR('ENTER: Fatal Error')
  332.  
  333.       ELSE IF (LENGTH(IPDEFN).GE.PARLEN) THEN
  334.           CALL ZCHOUT('Parameter definition of "',STDERR)
  335.           CALL PUTLIN(IPNAME,STDERR)
  336.           CALL ZMESS('" is too long',STDERR)
  337.           CALL ERROR('ENTER: Fatal Error')
  338.       END IF
  339.  
  340.       CALL ZTOCAP(IPNAME)
  341.       CALL ZITOF(IPNAME,1,PARLEN,PNAME,.FALSE.)
  342.       CALL ZITOF(IPDEFN,1,PARLEN,PDEFN,.FALSE.)
  343.  
  344.       I = 1
  345.   100 IF (I.LE.NPARMS) THEN
  346.           IF (PNAME.EQ.PTABLE(1,I)) CALL ERROR('Parameter '//
  347.      +        PNAME(:NAMLEN)//' duplicated')
  348.           I = I + 1
  349.           GO TO 100
  350.  
  351.       END IF
  352.  
  353.       NPARMS = NPARMS + 1
  354.       PTABLE(1,NPARMS) = PNAME
  355.       PTABLE(2,NPARMS) = PDEFN
  356.  
  357.       END
  358. C ----------------------------------------------------------------------
  359. C
  360. C       L O O K U P   -   Look a parameter definition up in a table
  361. C
  362.  
  363.       LOGICAL FUNCTION LOOKUP(IPNAME,PTABLE,NPARMS,IPDEFN)
  364.  
  365.       INTEGER EOS
  366.       PARAMETER (EOS=129)
  367.  
  368.       INTEGER PARLEN
  369.       PARAMETER (PARLEN=48)
  370.  
  371.       INTEGER NPARMS,IPNAME(*),IPDEFN(*)
  372.       CHARACTER*(PARLEN) PTABLE(2,NPARMS)
  373.  
  374.       INTEGER I,J
  375.       CHARACTER*(PARLEN) PNAME
  376.  
  377.       EXTERNAL ZITOF,ZFTOI,ZTOCAP
  378.  
  379.       CALL ZTOCAP(IPNAME)
  380.       CALL ZITOF(IPNAME,1,PARLEN,PNAME,.FALSE.)
  381.       DO 200 I = 1,NPARMS
  382.           IF (PNAME.EQ.PTABLE(1,I)) THEN
  383.               LOOKUP = .TRUE.
  384.               CALL ZFTOI(PTABLE(2,I),1,PARLEN,IPDEFN,.FALSE.)
  385.               DO 100 J = PARLEN,1,-1
  386.                   IF (PTABLE(2,I) (J:J).NE.' ') RETURN
  387.                   IPDEFN(J) = EOS
  388.   100         CONTINUE
  389.               RETURN
  390.  
  391.           END IF
  392.  
  393.   200 CONTINUE
  394.       LOOKUP = .FALSE.
  395.  
  396.       END
  397.